﻿<%
Sub echo(s)
Response.Write(s)
End Sub
'-------------------------------------------------------------------------------------
function Sp(path)
Sp=Server.MapPath(path)
end function
'-------------------------------------------------------------------------------------
function EnGUIDCode()
Dim objTypeLib,GUID
Set objTypeLib = CreateObject("Scriptlet.TypeLib")
str=objTypeLib.Guid
for i=1 to len(str) 
if (asc(mid(str,i,1))>=48 and asc(mid(str,i,1))=<57) or (asc(mid(str,i,1))>=65 and asc(mid(str,i,1))=<90) or (asc(mid(str,i,1))>=97 and asc(mid(str,i,1))=<122) then 
EnGUIDCode=EnGUIDCode&mid(str,i,1)
end if 
next
end function
'-------------------------------------------------------------------------------------
function Rndnumber(upperbound,lowerbound)
Randomize
Rndnumber=Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
end function
'-------------------------------------------------------------------------------------
function nedstr(str)
for i=1 to len(str) 
if (asc(mid(str,i,1))>=48 and asc(mid(str,i,1))=<57) or (asc(mid(str,i,1))>=65 and asc(mid(str,i,1))=<90) or (asc(mid(str,i,1))>=97 and asc(mid(str,i,1))=<122) or mid(str,i,1)="_" or mid(str,i,1)="-" or mid(str,i,1)="." then 
nedstr=nedstr&mid(str,i,1)
end if 
next
end function
'-------------------------------------------------------------------------------------
Function GetNumber(mystring)
Dim i
Dim str
For i = 1 To Len(mystring)
    If IsNumeric(Mid(mystring, i, 1)) Then
        str = str & Mid(mystring, i, 1)
    End If
Next
GetNumber = Cint(str)
End Function
'-------------------------------------------------------------------------------------
function Ip() 
Dim ipStr
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" OR InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),"unknown") > 0 Then
ipStr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),",") > 0 Then
ipStr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),";") > 0 Then
ipStr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),1,InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),";")-1)
Else
ipStr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
Ip = Trim(Mid(ipStr,1,30))
end function
'-------------------------------------------------------------------------------------
Function readtext(textpath)
dim temp
Set fs=Server.CreateObject("Scripting.FileSystemObject")
Set f=fs.OpenTextFile(Server.MapPath(textpath), 1)
do while f.AtEndOfStream = false
temp=temp&f.ReadLine& vbcrlf
loop
f.Close
Set f=Nothing
Set fs=Nothing
readtext=temp
temp=""
end function
'-------------------------------------------------------------------------------------
Function DateTimeToGMT(sDate)
Dim dWeek,dMonth
Dim strZero,strZone
strZero="00"
strZone="+0800"
dWeek=Array("Sun","Mon","Tue","Wes","Thu","Fri","Sat")
dMonth=Array("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")
DateTimeToGMT = dWeek(WeekDay(sDate)-1)&", "&_
Right(strZero&Day(sDate),2)&" "&_
dMonth(Month(sDate)-1)&" "&Year(sDate)&_
" "&Right(strZero&Hour(sDate),2)&":"&_
Right(strZero&Minute(sDate),2)&":"&_
Right(strZero&Second(sDate),2)&" "&strZone
end function
'-------------------------------------------------------------------------------------
'UTF转GB2312   将UTF8编码文字转换为GB编码文字的asp代码
function UTF2GB(UTFStr) 
for Dig=1 to len(UTFStr) 
   '如果UTF8编码文字以%开头则进行转换 
   if mid(UTFStr,Dig,1)="%" then 
      'UTF8编码文字大于8则转换为汉字 
     if len(UTFStr) >= Dig+8 then 
        GBStr=GBStr & ConvChinese(mid(UTFStr,Dig,9)) 
        Dig=Dig+8 
     else 
       GBStr=GBStr & mid(UTFStr,Dig,1) 
     end if 
   else 
      GBStr=GBStr & mid(UTFStr,Dig,1) 
   end if 
next 
UTF2GB=GBStr 
'老吧提供
end function

'GB2312转UTF8的asp代码 将GB编码文字转换为UTF8编码文字
Function toUTF8(szInput) 
     Dim wch, uch, szRet 
     Dim x 
     Dim nAsc, nAsc2, nAsc3 
     '如果输入参数为空，则退出函数 
     If szInput = "" Then 
         toUTF8 = szInput 
         Exit Function 
     End If 
     '开始转换 
      For x = 1 To Len(szInput) 
         '利用mid函数分拆GB编码文字 
         wch = Mid(szInput, x, 1) 
         '利用ascW函数返回每一个GB编码文字的Unicode字符代码 
         '注：asc函数返回的是ANSI 字符代码，注意区别 
         nAsc = AscW(wch) 
         If nAsc < 0 Then nAsc = nAsc + 65536 
     
         If (nAsc And &HFF80) = 0 Then 
             szRet = szRet & wch 
         Else 
             If (nAsc And &HF000) = 0 Then 
                 uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80) 
                 szRet = szRet & uch 
             Else 
                'GB编码文字的Unicode字符代码在0800 - FFFF之间采用三字节模版 
                 uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _ 
                             Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _ 
                             Hex(nAsc And &H3F Or &H80) 
                 szRet = szRet & uch 
             End If 
         End If 
     Next          
     toUTF8 = szRet 
End Function

'二进制转换为十六进制的asp代码
function c2to16(x) 
    i=1 
    for i=1 to len(x) step 4 
       c2to16=c2to16 & hex(c2to10(mid(x,i,4))) 
    next 
end function

'二进制转换为十进制的asp代码
function c2to10(x) 
    c2to10=0 
    if x="0" then exit function 
      i=0 
    for i= 0 to len(x) -1 
       if mid(x,len(x)-i,1)="1" then c2to10=c2to10+2^(i) 
    next 
end function

'十六进制转换为二进制的asp代码
function c16to2(x) 
     i=0 
     for i=1 to len(trim(x)) 
       tempstr= c10to2(cint(int("&h" & mid(x,i,1)))) 
       do while len(tempstr)<4 
          tempstr="0" & tempstr 
       loop 
       c16to2=c16to2 & tempstr 
    next 
end function 

function c10to2(x) 
    mysign=sgn(x) 
    x=abs(x) 
    DigS=1 
    do 
       if x<2^DigS then 
         exit do 
       else 
         DigS=DigS+1 
       end if 
    loop 
    tempnum=x 
    i=0 
    for i=DigS to 1 step-1 
       if tempnum>=2^(i-1) then 
          tempnum=tempnum-2^(i-1) 
          c10to2=c10to2 & "1" 
       else 
          c10to2=c10to2 & "0" 
       end if 
    next 
    if mysign=-1 then c10to2="-" & c10to2 
end function

'UTF8编码文字将转换为汉字
function ConvChinese(x) 
    A=split(mid(x,2),"%") 
    i=0 
    j=0 
   for i=0 to ubound(A) 
      A(i)=c16to2(A(i)) 
   next 
   for i=0 to ubound(A)-1 
     DigS=instr(A(i),"0") 
     Unicode="" 
     for j=1 to DigS-1 
       if j=1 then 
         A(i)=right(A(i),len(A(i))-DigS) 
         Unicode=Unicode & A(i) 
       else 
          i=i+1 
          A(i)=right(A(i),len(A(i))-2) 
          Unicode=Unicode & A(i) 
       end if 
     next 
     if len(c2to16(Unicode))=4 then 
        ConvChinese=ConvChinese & chrw(int("&H" & c2to16(Unicode))) 
     else 
        ConvChinese=ConvChinese & chr(int("&H" & c2to16(Unicode))) 
     end if 
   next 
end function

'GB2312中文转unicode(&#)的asp代码 将GB编码文字转换为unicode编码文字
function chinese2unicode(Str) 
   dim i 
   dim Str_one 
   dim Str_unicode 
   if(isnull(Str)) then 
      exit function 
   end if 
   for i=1 to len(Str) 
     Str_one=Mid(Str,i,1) 
     Str_unicode=Str_unicode&chr(38) 
     Str_unicode=Str_unicode&chr(35) 
     Str_unicode=Str_unicode&chr(120) 
     Str_unicode=Str_unicode& Hex(ascw(Str_one)) 
     Str_unicode=Str_unicode&chr(59) 
   next 
   chinese2unicode=Str_unicode 
end function  

'URL地址编码解码函数
Function URLDecode(enStr) 
dim deStr 
dim c,i,v 
deStr="" 
for i=1 to len(enStr) 
   c=Mid(enStr,i,1) 
   if c="%" then 
    v=eval("&h"+Mid(enStr,i+1,2)) 
    if v<128 then 
     deStr=deStr&chr(v) 
     i=i+2 
    else 
     if isvalidhex(mid(enstr,i,3)) then 
      if isvalidhex(mid(enstr,i+3,3)) then 
       v=eval("&h"+Mid(enStr,i+1,2)+Mid(enStr,i+4,2)) 
       deStr=deStr&chr(v) 
       i=i+5 
      else 
       v=eval("&h"+Mid(enStr,i+1,2)+cstr(hex(asc(Mid(enStr,i+3,1))))) 
       deStr=deStr&chr(v) 
       i=i+3 
      end if 
     else 
      destr=destr&c 
     end if 
    end if 
   else 
    if c="+" then 
     deStr=deStr&" " 
    else 
     deStr=deStr&c 
    end if 
   end if 
next 
URLDecode=deStr 
end function

'判断是否为有效的十六进制代码
''老吧提供
function isvalidhex(str) 
dim c 
isvalidhex=true 
str=ucase(str) 
if len(str)<>3 then isvalidhex=false:exit function 
if left(str,1)<>"%" then isvalidhex=false:exit function 
   c=mid(str,2,1) 
if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then isvalidhex=false:exit function 
   c=mid(str,3,1) 
if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then isvalidhex=false:exit function 
end function
'----------------------------------------------------------------
Function GetHttpPage(HttpUrl)
on error resume next
If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then
GetHttpPage="$False$"
Exit Function
End If
Dim Http
Set Http=server.createobject("MSX" & "ML2.XM" & "LHT" & "TP")
Http.open "GET",HttpUrl,False
Http.Send()
If Http.Readystate<>4 then
Set Http=Nothing
GetHttpPage="$False$"
Exit function
End if
GetHTTPPage=bytesToBSTR(Http.responseBody,"utf-8")
GetHTTPPage=replace(replace(GetHTTPPage , vbCr,""),vbLf,"")
Set Http=Nothing
If Err.number<>0 then
Err.Clear
End If
end function
'`````````````````````````````````````````````````````````````````````````````````````
Function BytesToBstr(Body,Cset)
on error resume next
Dim Objstream
Set Objstream = Server.CreateObject("ad" & "odb.str" & "eam")
objstream.Type = 1
objstream.Mode =3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
set objstream = nothing
end function
'`````````````````````````````````````````````````````````````````````````````````````
function GetwpathHTTPPage(path)
dim wpath
wpath=Server.MapPath(path)
wpath=Replace(wpath,request.ServerVariables("APPL_PHYSICAL_PATH"),"")
wpath="http://"&request.ServerVariables("HTTP_HOST")&"/"&wpath
GetwpathHTTPPage=GetHttpPage(wpath)
end function
'-------------------------------------------------------------------------------------
Sub DelayTime(secondNumber) 
dim startTime 
startTime=NOW() 
do while datediff("s",startTime,NOW())<secondNumber 
loop 
End Sub 
'-------------------------------------------------------------------------------------
function nohtml(str) 
dim re 
Set re=new RegExp 
re.IgnoreCase =true 
re.Global=True 
str = replace(str,"<img","[&#22270;]<img")
str = replace(str,"<a","{a")
str = replace(str,"</a>","{/a}")
str = replace(str,"<br>","{br}")
str = replace(str,"<br/>","{br}")
str = replace(str,"<br />","{br}")
str = replace(str,"<p>","{br}")
re.Pattern="(\<.[^\<]*\>)" 
str=re.replace(str," ") 
re.Pattern="(\<\/[^\<]*\>)" 
str=re.replace(str," ") 
str = replace(str,"{br}","<br>")
str = replace(str,"{a","<a")
str = replace(str,"{/a}","</a>")
if left(str,3)="<br>" then str=right(str,len(str)-3)
nohtml=str 
set re=nothing 
end function
Function SplitLines(Content,ContentNums)
Dim ts, i, l
ContentNums = Int(ContentNums)
If IsNull(Content) Then Exit Function
i = 1
ts = 0
For i = 1 To Len(Content)
l = LCase(Mid(Content, i, 5))
If l = "<br/>" Then
ts = ts + 1
End If
l = LCase(Mid(Content, i, 4))
If l = "<br>" Then
ts = ts + 1
End If
l = LCase(Mid(Content, i, 3))
If l = "<p>" Then
ts = ts + 1
End If
If ts>ContentNums Then Exit For
Next
If ts>ContentNums Then
Content = Left(Content, i -1)
End If
SplitLines = Content
End Function
Function CutStr(Str,StrLen)
Dim l, t, c, i
If IsNull(Str) Then
CutStr = ""
Exit Function
End If
l = Len(Str)
StrLen = Int(StrLen)
t = 0
For i = 1 To l
c = Asc(Mid(Str, i, 1))
If c<0 Or c>255 Then t = t + 2 Else t = t + 1
If t>= StrLen Then
CutStr = Left(Str, i)&"............"
Exit For
Else
CutStr = Str
End If
Next
End Function
'------------------------------------------------------------------------------------- 
Function wpath(URL,wtype)
on error resume next
wpatha=Server.MapPath(URL)
wpatha=Replace(wpatha,request.ServerVariables("APPL_PHYSICAL_PATH"),"")
wpatha="http://"&request.ServerVariables("HTTP_HOST")&"/"&wpatha
if wtype="1" then URL=Replace(URL,wpatha,"")
wpath=wpatha
End Function
'------------------------------------------------------------------------------------- 
Function gettag(num)
gettag=tags.childNodes.item(num).text
end function
'-------------------------------------------------------------------------------------
Function GDInfo(Gtype,Gnumber)
if Gtype="diary_id"     then GDInfo=diaryl.childNodes.item(Gnumber).childNodes.item(0).text
if Gtype="diary_tittle" then GDInfo=diaryl.childNodes.item(Gnumber).childNodes.item(1).text
if Gtype="diary_path"   then GDInfo=diaryl.childNodes.item(Gnumber).childNodes.item(2).text
if Gtype="diary_time"   then GDInfo=diaryl.childNodes.item(Gnumber).childNodes.item(3).text
if Gtype="diary_tags"   then GDInfo=diaryl.childNodes.item(Gnumber).attributes.item(0).value
if Gtype="diary_kind"   then GDInfo=diaryl.childNodes.item(Gnumber).attributes.item(1).value
if Gtype="diary_un"     then GDInfo=diaryl.childNodes.item(Gnumber).attributes.item(2).value
end function
'-------------------------------------------------------------------------------------
Session(seesionname&"_login_"&Request.Cookies(cookiesname&"_Login_sjcode")&"_State")=Session(seesionname&"_login_"&Request.Cookies(cookiesname&"_Login_sjcode")&"_State")
Session(seesionname&"_login_"&request.Cookies(cookiesname&"_Login_sjcode")&"_Nick")=Session(seesionname&"_login_"&request.Cookies(cookiesname&"_Login_sjcode")&"_Nick")
ULS=Session(seesionname&"_login_"&Request.Cookies(cookiesname&"_Login_sjcode")&"_State")
ULN=Session(seesionname&"_login_"&request.Cookies(cookiesname&"_Login_sjcode")&"_Nick")
Function UserPanel
if ULS="" then
UserPanel="<a href='login.asp'>登录</a><br><a href='Register.asp'>注册</a>"
else
UserPanel="欢迎回来,"&ULN&"<br><a href='control'>后台</a>"
end if
end Function
'--------------------------------------------------------------------------------------
Function sidebar
	maxid=0
	plus_feeds=""
	sidebar_feed=readtext(skinf&"/boards/sidebar.html")
	sidebar_for =readtext(skinf&"/boards/sidebar_tbody.html")
	

	for i=0 to PlusDBRootcount
		plus_feed_id   =GetNumber(PlusDBRoot.childNodes.item(i).attributes.item(0).value)
		if plus_feed_id>maxid then maxid=plus_feed_id
	next
	dim plus_feed
	redim plus_feed(maxid)
	for i=0 to maxid
		plus_feed(i)=""
	next
	for i=0 to PlusDBRootcount
		plus_feed_where=PlusDBRoot.childNodes.item(i).childNodes.item(0).text
		plus_feed_name =PlusDBRoot.childNodes.item(i).childNodes.item(1).text
		plus_feed_url  =PlusDBRoot.childNodes.item(i).childNodes.item(2).text
		plus_feed_id   =GetNumber(PlusDBRoot.childNodes.item(i).attributes.item(0).value)
		feedcode=GetwpathHTTPPage(plus_path&"/"&plus_feed_url&"/code.asp")
		if feedcode="<$UserPanel$>" then feedcode=UserPanel
			if plus_feed(plus_feed_id)="" then
				plus_feed(plus_feed_id)=replace(sidebar_for,"<$sidebar_tbody_title$>",plus_feed_name)
				plus_feed(plus_feed_id)=replace(plus_feed(plus_feed_id),"<$sidebar_tbody_texts$>",feedcode)
			else
				plus_feedtemp=replace(sidebar_for,"<$sidebar_tbody_title$>",plus_feed_name)
				plus_feedtemp=replace(feedtemp,"<$sidebar_tbody_texts$>",feedcode)
				plus_feed(plus_feed_id)=plus_feed(plus_feed_id)&plus_feedtemp
			end if
	next
	for j=0 to maxid
		plus_feeds=plus_feeds&plus_feed(j)
	Next
	sidebar=replace(sidebar_feed,"<$sidebar_tbody$>",plus_feeds)
end Function
'--------------------------------------------------------------------------------------
Function pagemodels(where)
if where="bodytop" then pagemodels=readtext(skinf&"/boards/page_s.html") 
if where="bodyend" then pagemodels=readtext(skinf&"/boards/page_e.html") 
end Function
'--------------------------------------------------------------------------------------
Function footer
footer=readtext(skinf&"\boards\footer.html")
end Function
%>
